home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / contrib / zelk / scm / parseargs.e < prev    next >
Encoding:
Text File  |  1992-10-17  |  5.8 KB  |  229 lines
  1. ;; parseargs.e zilla oct92 - elkscheme commandline argument parser
  2. ;; (parseargs <argument-description> <body>)
  3. ;; Evaluates body in a let* context with command-line arguments parsed
  4. ;; and bound as described in argument-description.
  5. ;;
  6. ;; There are three types of arguments:
  7. ;; - required arguments
  8. ;; - flags, which look like "--flag"
  9. ;; - optional arguments, which look like "-opt <arg>"
  10. ;;
  11. ;; An argument description (argspec) is:
  12. ;; ([flag-string] [type] symbol [default-value]) or just 'symbol'
  13. ;; Flag-string is a string preceeding an optional value.
  14. ;; Type is one of integer,real,symbol.
  15. ;; Symbol is the symbol which will be bound to the command line argument.
  16. ;; Default-value is a default value for optional arguments.
  17. ;;
  18. ;; Flag-strings with one hyphen, e.g. "-n", should preceed a corresponding
  19. ;; argument.  ("-n" integer n 0) would match ..."-n" "3"...
  20. ;; If the flag-string is not on the command line, the symbol is bound to #f.
  21. ;;
  22. ;; Flag arguments having two hyphens, e.g. "--v", are simply flags--
  23. ;; there is no associated argument. The symbol is bound to #t if
  24. ;; the flag is present, otherwise to #f.
  25. ;;
  26. ;; Example: with the command line arguments 
  27. ;;    ("foo.esh" "myfile" "3" "3.3" "--v" "-j" "11")
  28. ;; the call
  29. ;;     (parseargs (fname 
  30. ;;            (integer ivar)
  31. ;;            var
  32. ;;            ("--v" flag)
  33. ;;            ("-j" integer flagarg "5")
  34. ;;           )
  35. ;;           <body>)
  36. ;; expands to
  37. ;;    (let*  ((fname "myfile")
  38. ;;        (ivar 3)
  39. ;;        (var "3.3")
  40. ;;        (flag #t)
  41. ;;        (flagarg 11))
  42. ;;       <body>)
  43. ;;
  44. ;; Note that the first command line argument (the name of the current 
  45. ;; program) is ignored.
  46.  
  47.  
  48. (define-macro (parseargs . body)
  49.   (let* ((args (car body))
  50.      (body (cdr body))
  51.      (bindings '())
  52.      (clargs (cdr (command-line-args)))
  53.      (clflagargs '())
  54.      (clflags '())
  55.      (clmainargs '())
  56.      (clarg nil)
  57.      ;(optional #f)
  58.     )
  59.  
  60.       (define type-names '(integer real symbol))
  61.  
  62.     ;; put argspec in standard form (string|#f type|#f symbol default|#f)
  63.     (define (cannonify arg)
  64.       (let ((fullarg '())
  65.         (str #f)
  66.         (typ #f)
  67.         (sym #f)
  68.         (default #f)
  69.         )
  70.         (cond
  71.          ((list? arg)
  72.           (if (and (car arg) (string? (car arg)))
  73.           (pop arg str))
  74.           (if (and (car arg) (member (car arg) type-names))
  75.           (pop arg typ))
  76.           (if (not arg) (error 'parseargs "argspec missing symbol~%"))
  77.           (pop arg sym)
  78.           (if arg (set! default (car arg))))
  79.  
  80.          ((symbol? arg)
  81.           (set! sym arg))
  82.  
  83.          (else (error 'parseargs "bad argspec: ~s" arg))
  84.         );cond
  85.  
  86.         (list str typ sym default)
  87.       )
  88.     );cannonify
  89.  
  90.  
  91.     (define (flag? arg)
  92.       (let ((arg0 (list-ref arg 0)))
  93.         (and (string? arg0) (equal? "--" (substring arg0 0 2)))))
  94.  
  95.     (define (optional? arg)
  96.       (let ((arg0 (list-ref arg 0)))
  97.         (and (string? arg0)
  98.          (equal? "-" (substring arg0 0 1))
  99.          (not (equal? "-" (substring arg0 1 2))))))
  100.  
  101.  
  102.     ;; flag argument "--v", bind symbol to #t if present else #f
  103.     (define (matchflag arg)
  104.       (let* ((flagname (list-ref arg 0))
  105.          (clflags (member flagname clflags))
  106.          (sym (list-ref arg 2))
  107.          )
  108.         ;(format #t "flag search found ~a~%" clflags)
  109.         (list sym (if clflags #t #f))
  110.       )
  111.     );flag #t/#f
  112.  
  113.  
  114.     ;; optional argument e.g. ("-n" integer n 1) 
  115.     (define (matchoptional arg)
  116.       (let* ((flag (list-ref arg 0))
  117.          (clflagargs (member flag clflagargs))
  118.          (clarg clarg)
  119.         )
  120.         ;(format #t "flag search found ~a~%" clargs)
  121.         (if clflagargs (set! clflagargs (cdr clflagargs)))
  122.         (if clflagargs (set! clarg (car clflagargs))
  123.         (set! clarg #f))
  124.         (if clarg
  125.         (matcharg (cons #f (cdr arg)) clarg)
  126.         (list (list-ref arg 2) #f))
  127.       )
  128.     );flag with argument
  129.  
  130.     (define (matchlist arg clarg)
  131.       ;(format #t "matchlist arg=~a~%" arg)
  132.       (let ((typ (list-ref arg 1))
  133.         (sym (list-ref arg 2))
  134.         (val #f)
  135.         (default (list-ref arg 3))
  136.            )
  137.  
  138.         (if (not clarg)
  139.         (error 'parseargs "missing arg: ~a" sym))
  140.         
  141.         (set! val
  142.           (case typ
  143.             ((symbol)        (string->symbol clarg))
  144.             ((number integer real) (string->number clarg))
  145.             ((#f)        clarg)
  146.             (else (error 'parsearg "unrecognized type: ~a" typ))))
  147.         (list sym val)
  148.       );let
  149.     );matchlist
  150.  
  151.  
  152.       ;; helper
  153.     (define (matcharg arg clarg)
  154.       ;(format #t "matcharg ~s ~s~%" arg clarg)
  155.       (cond
  156.  
  157.        ((flag? arg)
  158.         (matchflag arg))
  159.  
  160.        ((optional? arg)
  161.         (matchoptional arg))
  162.  
  163.        (else
  164.         (let ((m (matchlist arg clarg)))
  165.           (if clmainargs (set! clmainargs (cdr clmainargs)))
  166.           m))
  167.  
  168.  
  169.       );cond
  170.     );matcharg
  171.  
  172.  
  173.     ;; split flag arguments and optional arguments from required arguments
  174.     (while clargs
  175.       (let ((clarg (car clargs)))
  176.     (cond
  177.      ((and (>= (string-length clarg) 2)
  178.            (equal? "--" (substring clarg 0 2)))
  179.       (set! clflags (cons clarg clflags)))
  180.      ((equal? "-" (substring clarg 0 1))
  181.       (set! clflagargs (cons clarg clflagargs))
  182.       (set! clargs (cdr clargs))
  183.       (if (not clargs) (error 'parseargs "-flag missing arg: ~a" clarg))
  184.       (set! clflagargs (cons (car clargs) clflagargs)))
  185.      (else
  186.       (set! clmainargs (cons clarg clmainargs)))
  187.     )
  188.     (set! clargs (cdr clargs))
  189.       );let
  190.     );while
  191.  
  192.     (set! clmainargs (reverse! clmainargs))
  193.     (set! clflagargs (reverse! clflagargs))
  194.     (set! clargs (reverse! clargs))
  195.     ;(format #t "clmainargs = ~s~%" clmainargs)
  196.     ;(format #t "clflagargs = ~s~%" clflagargs)
  197.     ;(format #t "clflags = ~s~%" clflags)
  198.          
  199.     (dolist (arg args)
  200.     (set! arg (cannonify arg))
  201.     (if clmainargs
  202.         (set! clarg (car clmainargs))
  203.         (set! clarg #f))
  204.     (set! bindings (cons (matcharg arg clarg) bindings))
  205.     ;(format #t "bindings=~s~%" bindings)
  206.     );dolist
  207.  
  208.     `(let* ,(reverse! bindings)
  209.        ,@body)
  210.     
  211.   );let
  212. );parseargs
  213.  
  214.  
  215. ;(define (command-line-args)
  216. ;  (list "foo.esh" "foo.e" "-j" "133" "3" "3.3" )
  217. ;  ;(list "foo.esh" "foo.e" "3" "3.3" "--v" "-j" "11")
  218. ;)
  219.  
  220. ;(parseargs (fname 
  221. ;        (integer ivar)
  222. ;        var
  223. ;        ("--v" flag)
  224. ;        ("-j" integer flagarg "5")
  225. ;        )
  226. ;   (format #t "RESULT: fname=~a, ivar=~a, var=~s flag=~s flagarg=~s~%"
  227. ;       fname ivar var flag flagarg)
  228. ;)
  229.